home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / RMEMMGT.C < prev    next >
Text File  |  1990-03-11  |  46KB  |  1,598 lines
  1. /*
  2.  * File: rmemmgt.c
  3.  *  Contents: allocation routines, block description arrays, dump routines,
  4.  *  garbage collection, sweep
  5.  */
  6.  
  7. #include "::h:config.h"
  8. #include "::h:rt.h"
  9. #include "rproto.h"
  10.  
  11. #if MACINTOSH
  12. #if MPW
  13. #include <QuickDraw.h>
  14. #include <ToolUtils.h>
  15. #endif                    /* MPW */
  16. #endif                    /* MACINTOSH */
  17.  
  18. #ifdef IconAlloc
  19. /*
  20.  *  If IconAlloc is defined the system allocation routines are not overloaded.
  21.  *  The names are changed so that Icon's allocation routines are independently
  22.  *  used.  This works as long as no other system calls cause the break value
  23.  *  to change.
  24.  */
  25. #define malloc mem_alloc
  26. #define free mem_free
  27. #define realloc mem_realloc
  28. #define calloc mem_calloc
  29. #endif                                  /* IconAlloc */
  30.  
  31. /*
  32.  * Prototype.
  33.  */
  34.  
  35. hidden    union   block *alcblk   Params((uword nbytes,int tcode));
  36.  
  37. word coexp_ser = 1;    /* serial numbers for co-expressions; &main is 1 */
  38. word list_ser = 1;    /* serial numbers for lists */
  39. word set_ser = 1;    /* serial numbers for sets */
  40. word table_ser = 1;    /* serial numbers for tables */
  41.  
  42. word coll_stat = 0;             /* collections in static region */
  43. word coll_str = 0;              /* collections in string region */
  44. word coll_blk = 0;              /* collections in block region */
  45. word coll_tot = 0;              /* total collections */
  46.  
  47. #ifdef EvalTrace
  48. extern FILE *trfile;
  49. extern word colmno;
  50. extern word lineno;
  51. #endif                    /* EvalTrace */
  52.  
  53. #ifdef FixedRegions
  54. word alcnum = 0;                /* co-expressions allocated since g.c. */
  55. #endif                                  /* FixedRegions */
  56.  
  57. dptr *quallist;                 /* string qualifier list */
  58. dptr *qualfree;                         /* qualifier list free pointer */
  59. dptr *equallist;                /* end of qualifier list */
  60.  
  61. int qualfail;                   /* flag: quailifier list overflow */
  62.  
  63.  
  64. /*
  65.  * Note: function calls beginning with "MM" are just empty macros
  66.  * unless MemMon is defined.
  67.  */
  68.  
  69. /*
  70.  * Allocated block size table (sizes given in bytes).  A size of -1 is used
  71.  *  for types that have no blocks; a size of 0 indicates that the
  72.  *  second word of the block contains the size; a value greater than
  73.  *  0 is used for types with constant sized blocks.
  74.  */
  75.  
  76. int bsizes[] = {
  77.     -1,                       /* T_Null (0), not block */
  78.     -1,                       /* T_Integer (1), not block */
  79.  
  80. #ifdef LargeInts
  81.      0,                  /* T_Bignum (2), bignum */
  82. #else
  83.     -1,                       /* (2), not used */
  84. #endif                    /* LargeInts */
  85.  
  86.      sizeof(struct b_real),   /* T_Real (3), real number */
  87.      sizeof(struct b_cset),   /* T_Cset (4), cset */
  88.      sizeof(struct b_file),   /* T_File (5), file block */
  89.      0,                       /* T_Proc (6), procedure block */
  90.      sizeof(struct b_list),   /* T_List (7), list header block */
  91.      sizeof(struct b_table),  /* T_Table (8), table header block */
  92.      0,                       /* T_Record (9), record block */
  93.      sizeof(struct b_telem),  /* T_Telem (10), table element block */
  94.      0,                       /* T_Lelem (11), list element block */
  95.      sizeof(struct b_tvsubs), /* T_Tvsubs (12), substring trapped variable */
  96.     -1,                       /* T_Tvkywd (13), keyword trapped variable */
  97.      sizeof(struct b_tvtbl),  /* T_Tvtbl (14), table element trapped variable */
  98.      sizeof(struct b_set),    /* T_Set (15), set header block */
  99.      sizeof(struct b_selem),  /* T_Selem (16), set element block */
  100.      0,                       /* T_Refresh (17), refresh block */
  101.     -1,                       /* T_Coexpr (18), co-expression block */
  102.      0,                       /* T_External (19), external block */
  103.      0,                       /* T_Slots (20), set/table hash block */
  104.     };
  105.  
  106. /*
  107.  * Table of offsets (in bytes) to first descriptor in blocks.  -1 is for
  108.  *  types not allocated, 0 for blocks with no descriptors.
  109.  */
  110. int firstd[] = {
  111.     -1,                       /* T_Null (0), not block */
  112.     -1,                       /* T_Integer (1), not block */
  113.  
  114. #ifdef LargeInts
  115.      0,                  /* T_Bignum (2), bignum */
  116. #else
  117.     -1,                       /* (2), not used */
  118. #endif                    /* LargeInts */
  119.  
  120.      0,                       /* T_Real (3), real number */
  121.      0,                       /* T_Cset (4), cset */
  122.      3*WordSize,              /* T_File (5), file block */
  123.      7*WordSize,              /* T_Proc (6), procedure block */
  124.      0,                       /* T_List (7), list header block */
  125.      (4+HSegs)*WordSize,      /* T_Table (8), table header block */
  126.      4*WordSize,              /* T_Record (9), record block */
  127.      3*WordSize,              /* T_Telem (10), table element block */
  128.      7*WordSize,              /* T_Lelem (11), list element block */
  129.      3*WordSize,              /* T_Tvsubs (12), substring trapped variable */
  130.     -1,                       /* T_Tvkywd (13), keyword trapped variable */
  131.      3*WordSize,              /* T_Tvtbl (14), table element trapped variable */
  132.      0,                      /* T_Set (15), set header block */
  133.      3*WordSize,              /* T_Selem (16), set element block */
  134.      (4+Wsizeof(struct pf_marker))*WordSize,
  135.                               /* T_Refresh (17), refresh block */
  136.     -1,                       /* T_Coexpr (18), co-expression block */
  137.      0,                       /* T_External (19), external block */
  138.      0,                       /* T_Slots (20), set/table hash block */
  139.     };
  140.  
  141. /*
  142.  * Table of offsets (in bytes) to first pointer in blocks.  -1 is for
  143.  *  types not allocated, 0 for blocks with no pointers.
  144.  */
  145. int firstp[] = {
  146.     -1,                       /* T_Null (0), not block */
  147.     -1,                       /* T_Integer (1), not block */
  148.  
  149. #ifdef LargeInts
  150.      0,                  /* T_Bignum (2), bignum */
  151. #else
  152.     -1,                       /* (2), not used */
  153. #endif                    /* LargeInts */
  154.  
  155.      0,                       /* T_Real (3), real number */
  156.      0,                       /* T_Cset (4), cset */
  157.      0,                       /* T_File (5), file block */
  158.      0,                       /* T_Proc (6), procedure block */
  159.      3*WordSize,              /* T_List (7), list header block */
  160.      4*WordSize,              /* T_Table (8), table header block */
  161.      3*WordSize,              /* T_Record (9), record block */
  162.      1*WordSize,              /* T_Telem (10), table element block */
  163.      2*WordSize,              /* T_Lelem (11), list element block */
  164.      0,                       /* T_Tvsubs (12), substring trapped variable */
  165.     -1,                       /* T_Tvkywd (13), keyword trapped variable */
  166.      1*WordSize,              /* T_Tvtbl (14), table element trapped variable */
  167.      4*WordSize,              /* T_Set (15), set header block */
  168.      1*WordSize,              /* T_Selem (16), set element block */
  169.      0,                       /* T_Refresh (17), refresh block */
  170.     -1,                       /* T_Coexpr (18), co-expression block */
  171.      0,                       /* T_External (19), external block */
  172.      2*WordSize,              /* T_Slots (20), set/table hash block */
  173.     };
  174.  
  175. /*
  176.  * Table of number of pointers in blocks.  -1 is for types not allocated and
  177.  *  types without pointers, 0 for pointers through the end of the block.
  178.  */
  179. int ptrno[] = {
  180.     -1,                       /* T_Null (0), not block */
  181.     -1,                       /* T_Integer (1), not block */
  182.     -1,                       /* T_Bignum (2), large integer, or not used */
  183.     -1,                       /* T_Real (3), real number */
  184.     -1,                       /* T_Cset (4), cset */
  185.     -1,                       /* T_File (5), file block */
  186.     -1,                       /* T_Proc (6), procedure block */
  187.      2,                       /* T_List (7), list header block */
  188.      HSegs,                   /* T_Table (8), table header block */
  189.      1,                       /* T_Record (9), record block */
  190.      1,                       /* T_Telem (10), table element block */
  191.      2,                       /* T_Lelem (11), list element block */
  192.     -1,                       /* T_Tvsubs (12), substring trapped variable */
  193.     -1,                       /* T_Tvkywd (13), keyword trapped variable */
  194.      1,                       /* T_Tvtbl (14), table element trapped variable */
  195.      HSegs,                   /* T_Set (15), set header block */
  196.      1,                       /* T_Selem (16), set element block */
  197.     -1,                       /* T_Refresh (17), refresh block */
  198.     -1,                       /* T_Coexpr (18), co-expression block */
  199.     -1,                       /* T_External (19), external block */
  200.      0,                       /* T_Slots (20), set/table hash block */
  201.     };
  202.  
  203. /*
  204.  * Table of block names used by debugging functions.
  205.  */
  206. char *blkname[] = {
  207.    "illegal object",                    /* T_Null (0), not block */
  208.    "illegal object",                    /* T_Integer (1), not block */
  209.  
  210. #ifdef LargeInts
  211.    "large integer",            /* T_Bignum (2), bignum */
  212. #else
  213.    "illegal object",                    /* not used */
  214. #endif                    /* LargeInts */
  215.  
  216.    "real number",                       /* T_Real (3) */
  217.    "cset",                              /* T_Cset (4) */
  218.    "file",                              /* T_File (5) */
  219.    "procedure",                         /* T_Proc (6) */
  220.    "list",                              /* T_List (7) */
  221.    "table",                             /* T_Table (8) */
  222.    "record",                            /* T_Record (9) */
  223.    "table element",                     /* T_Telem (10) */
  224.    "list element",                      /* T_Lelem (11) */
  225.    "substring trapped variable",        /* T_Tvsubs (12) */
  226.    "keyword trapped variable",          /* T_Tvkywd (13) */
  227.    "table element trapped variable",    /* T_Tvtbl (14) */
  228.    "set",                               /* T_Set (15) */
  229.    "set elememt",                       /* T_Selem (16) */
  230.    "refresh block",                     /* T_Refresh (17) */
  231.    "co-expression",                     /* T_Coexpr (18) */
  232.    "external block",                    /* T_External (19) */
  233.    "hash block",                        /* T_Slots (20) */
  234.    };
  235.  
  236. /*
  237.  * Sizes of hash chain segments.
  238.  *  Table size must equal or exceed HSegs.
  239.  */
  240. uword segsize[] = {
  241.    ((uword)HSlots),            /* segment 0 */
  242.    ((uword)HSlots),            /* segment 1 */
  243.    ((uword)HSlots) << 1,        /* segment 2 */
  244.    ((uword)HSlots) << 2,        /* segment 3 */
  245.    ((uword)HSlots) << 3,        /* segment 4 */
  246.    ((uword)HSlots) << 4,        /* segment 5 */
  247.    ((uword)HSlots) << 5,        /* segment 6 */
  248.    ((uword)HSlots) << 6,        /* segment 7 */
  249.    ((uword)HSlots) << 7,        /* segment 8 */
  250.    ((uword)HSlots) << 8,        /* segment 9 */
  251.    ((uword)HSlots) << 9,        /* segment 10 */
  252.    ((uword)HSlots) << 10,        /* segment 11 */
  253.    };
  254.  
  255. #ifdef FixedRegions
  256. #include "rmemfix.c"
  257. #else                                   /* FixedRegions */
  258. #include "rmemexp.c"
  259. #endif                                  /* FixedRegions */
  260.  
  261. /*
  262.  * alcblk - returns pointer to nbytes of free storage in block region.
  263.  */
  264.  
  265. static union block *alcblk(nbytes,tcode)
  266. uword nbytes;
  267. int tcode;
  268.    {
  269.    register uword fspace, *sloc;
  270.  
  271.    /*
  272.     * See if there is enough room in the block region.
  273.     */
  274.    fspace = DiffPtrs(blkend,blkfree);
  275.    if (fspace < nbytes)
  276.       syserr("block allocation botch");
  277.  
  278.    /*
  279.     * If monitoring, show the allocation.
  280.     */
  281.    MMAlc((word)nbytes,tcode);
  282.  
  283. #ifdef EvalTrace
  284.    if (trfile) {
  285.       fprintf(trfile,"a\t%ld\t%ld\t%d\t%ld\n",colmno,lineno,tcode,nbytes);
  286.       }
  287. #endif                    /* EvalTrace */
  288.  
  289.    /*
  290.     * Decrement the free space in the block region by the number of bytes
  291.     *  allocated and return the address of the first byte of the allocated
  292.     *  block.
  293.     */
  294.    sloc = (uword *)blkfree;
  295.    blkneed -= nbytes;
  296.    blkfree += nbytes;
  297.    BlkType(sloc) = tcode;
  298.    return (union block *)(sloc);
  299.    }
  300.  
  301. /*
  302.  * alcreal - allocate a real value in the block region.
  303.  */
  304.  
  305. struct b_real *alcreal(val)
  306. double val;
  307.    {
  308.    register struct b_real *blk;
  309.  
  310.    blk = (struct b_real *)alcblk((uword)sizeof(struct b_real), T_Real);
  311.  
  312. #ifdef Double
  313. /* access real values one word at a time */
  314.    { int *rp, *rq;
  315.      rp = (word *) &(blk->realval);
  316.      rq = (word *) &val;
  317.      *rp++ = *rq++;
  318.      *rp   = *rq;
  319.    }
  320. #else                                   /* Double */
  321.    blk->realval = val;
  322. #endif                                  /* Double */
  323.  
  324.    return blk;
  325.    }
  326.  
  327. #ifdef LargeInts
  328. /*
  329.  * alcbignum - allocate an n-digit bignum in the block region
  330.  */
  331.  
  332. struct b_bignum *alcbignum(n)
  333. word n;
  334.    {
  335.    register struct b_bignum *blk;
  336.    register uword size;
  337.  
  338.    size = sizeof(struct b_bignum) + ((n - 1) * sizeof(DIGIT));
  339.    /* ensure whole number of words allocated */
  340.    size = (size + WordSize - 1) & -WordSize;
  341.    blk = (struct b_bignum *)alcblk(size, T_Bignum);
  342.    blk->blksize = size;
  343.    blk->msd = blk->sign = 0;
  344.    blk->lsd = n - 1;
  345.    return blk;
  346.    }
  347. #endif                    /* LargeInts */
  348.  
  349. /*
  350.  * alccset - allocate a cset in the block region.
  351.  */
  352.  
  353. struct b_cset *alccset()
  354.    {
  355.    register struct b_cset *blk;
  356.    register int i;
  357.  
  358.    blk = (struct b_cset *)alcblk((uword)sizeof(struct b_cset), T_Cset);
  359.    blk->size = -1;              /* flag size as not yet computed */
  360.  
  361.    /*
  362.     * Zero the bit array.
  363.     */
  364.    for (i = 0; i < CsetSize; i++)
  365.      blk->bits[i] = 0;
  366.    return blk;
  367.    }
  368.  
  369. /*
  370.  * alcfile - allocate a file block in the block region.
  371.  */
  372.  
  373. struct b_file *alcfile(fd, status, name)
  374. FILE *fd;
  375. int status;
  376. dptr name;
  377.    {
  378.    register struct b_file *blk;
  379.  
  380.    blk = (struct b_file *)alcblk((uword)sizeof(struct b_file), T_File);
  381.    blk->fd = fd;
  382.    blk->status = status;
  383.    blk->fname = *name;
  384.    return blk;
  385.    }
  386.  
  387. /*
  388.  * alcrecd - allocate record with nflds fields in the block region.
  389.  */
  390.  
  391. struct b_record *alcrecd(nflds, recptr)
  392. int nflds;
  393. union block **recptr;
  394.    {
  395.    register struct b_record *blk;
  396.    register int size;
  397.  
  398.    size = Vsizeof(struct b_record) + nflds*sizeof(struct descrip);
  399.    blk = (struct b_record *)alcblk((uword)size, T_Record);
  400.    blk->blksize = size;
  401.    blk->recdesc = (union block *)recptr;
  402.    return blk;
  403.    }
  404.  
  405. /*
  406.  * alcextrnl - allocate an external block.
  407.  */
  408.  
  409. struct b_external *alcextrnl(n)
  410. int n;
  411.    {
  412.    register struct b_external *blk;
  413.  
  414.    blk = (struct b_external *)alcblk((uword)(n * sizeof(word)), T_External);
  415.    blk->blksize = (n + 3) * sizeof(word);
  416.    blk->descoff = 0;
  417.    /* probably ought to clear the rest of the block */
  418.    return blk;
  419.    }
  420.  
  421. /*
  422.  * alclist - allocate a list header block in the block region.
  423.  */
  424.  
  425. struct b_list *alclist(size)
  426. uword size;
  427.    {
  428.    static word list_ser = 1;
  429.    register struct b_list *blk;
  430.  
  431.    blk = (struct b_list *)alcblk((uword)sizeof(struct b_list), T_List);
  432.    blk->size = size;
  433.    blk->listhead = NULL;
  434.    blk->listtail = NULL;
  435.    blk->id = list_ser++;
  436.    return blk;
  437.    }
  438.  
  439. /*
  440.  * alclstb - allocate a list element block in the block region.
  441.  */
  442.  
  443. struct b_lelem *alclstb(nslots, first, nused)
  444. uword nslots, first, nused;
  445.    {
  446.    register struct b_lelem *blk;
  447.    register word i, size;
  448.  
  449.    size = Vsizeof(struct b_lelem) + nslots * sizeof(struct descrip);
  450.    blk = (struct b_lelem *)alcblk((uword)size, T_Lelem);
  451.    blk->blksize = size;
  452.    blk->nslots = nslots;
  453.    blk->first = first;
  454.    blk->nused = nused;
  455.    blk->listprev = NULL;
  456.    blk->listnext = NULL;
  457.    /*
  458.     * Set all elements to &null.
  459.     */
  460.    for (i = 0; i < nslots; i++)
  461.       blk->lslots[i] = nulldesc;
  462.    return blk;
  463.    }
  464.  
  465. /*
  466.  * alchash - allocate a hashed structure (set or table header) in the block
  467.  *  region.
  468.  */
  469.  
  470. union block *alchash(tcode)
  471. int tcode;
  472.    {
  473.    static word table_ser = 1;
  474.    static word set_ser = 1;
  475.  
  476.    register int i;
  477.    register union block *blk;
  478.    word serial;
  479.    uword blksize;
  480.  
  481.    if (tcode == T_Table) {
  482.       serial = table_ser++;
  483.       blksize = sizeof(struct b_table);
  484.       }
  485.    else {    /* tcode == T_Set */
  486.       serial = set_ser++;
  487.       blksize = sizeof(struct b_set);
  488.       }
  489.    blk = alcblk(blksize, tcode);
  490.    blk->set.size = 0;
  491.    blk->set.id = serial;
  492.    blk->set.mask = 0;
  493.    for (i = 0; i < HSegs; i++)
  494.       blk->set.hdir[i] = NULL;
  495.    return blk;
  496.    }
  497.  
  498. /*
  499.  * alcsegment - allocate a slot block in the block region.
  500.  */
  501.  
  502. struct b_slots *alcsegment(nslots)
  503. word nslots;
  504.    {
  505.    uword size;
  506.    register struct b_slots *blk;
  507.  
  508.    size = sizeof(struct b_slots) + WordSize * (nslots - HSlots);
  509.    blk = (struct b_slots *)alcblk(size, T_Slots);
  510.    blk->blksize = size;
  511.    while (--nslots >= 0)
  512.       blk->hslots[nslots] = NULL;
  513.    return blk;
  514.    }
  515.  
  516. /*
  517.  * alctelem - allocate a table element block in the block region.
  518.  */
  519.  
  520. struct b_telem *alctelem()
  521.    {
  522.    register struct b_telem *blk;
  523.  
  524.    blk = (struct b_telem *)alcblk((uword)sizeof(struct b_telem), T_Telem);
  525.    blk->hashnum = 0;
  526.    blk->clink = NULL;
  527.    blk->tref = nulldesc;
  528.    blk->tval = nulldesc;
  529.    return blk;
  530.    }
  531.  
  532. /*
  533.  * alcselem - allocate a set element block.
  534.  */
  535.  
  536. struct b_selem *alcselem(mbr,hn)
  537. dptr mbr;
  538. uword hn;
  539.  
  540.    {
  541.    register struct b_selem *blk;
  542.  
  543.    blk = (struct b_selem *)alcblk((uword)sizeof(struct b_selem), T_Selem);
  544.    blk->clink = NULL;
  545.    blk->setmem = *mbr;
  546.    blk->hashnum = hn;
  547.    return blk;
  548.    }
  549.  
  550. /*
  551.  * alcsubs - allocate a substring trapped variable in the block region.
  552.  */
  553.  
  554. struct b_tvsubs *alcsubs(len, pos, var)
  555. word len, pos;
  556. dptr var;
  557.    {
  558.    register struct b_tvsubs *blk;
  559.  
  560.    blk = (struct b_tvsubs *)alcblk((uword)sizeof(struct b_tvsubs), T_Tvsubs);
  561.    blk->sslen = len;
  562.    blk->sspos = pos;
  563.    blk->ssvar = *var;
  564.    return blk;
  565.    }
  566.  
  567. /*
  568.  * alctvtbl - allocate a table element trapped variable block in the block
  569.  *  region.
  570.  */
  571.  
  572. struct b_tvtbl *alctvtbl(tbl, ref, hashnum)
  573. register dptr tbl, ref;
  574. uword hashnum;
  575.    {
  576.    register struct b_tvtbl *blk;
  577.  
  578.    blk = (struct b_tvtbl *)alcblk((uword)sizeof(struct b_tvtbl), T_Tvtbl);
  579.    blk->hashnum = hashnum;
  580.    blk->clink = BlkLoc(*tbl);
  581.    blk->tref = *ref;
  582.    blk->tval = nulldesc;
  583.    return blk;
  584.    }
  585.  
  586. /*
  587.  * alcstr - allocate a string in the string space.
  588.  */
  589.  
  590. char *alcstr(s, slen)
  591. register char *s;
  592. register word slen;
  593.    {
  594.    register char *d;
  595.    register uword fspace;
  596.    char *ofree;
  597.  
  598.    MMStr(slen);
  599.  
  600. #ifdef EvalTrace
  601.    if (trfile) {
  602.       fprintf(trfile,"a\t%ld\t%ld\t%ld\n",colmno,lineno,slen);
  603.       }
  604. #endif                    /* EvalTrace */
  605.  
  606.    /*
  607.     * See if there is enough room in the string space.
  608.     */
  609.    fspace = DiffPtrs(strend,strfree);
  610.    if (fspace < slen)
  611.       syserr("string allocation botch");
  612.    strneed -= slen;
  613.  
  614.    /*
  615.     * Copy the string into the string space, saving a pointer to its
  616.     *  beginning.  Note that s may be null, in which case the space
  617.     *  is still to be allocated but nothing is to be copied into it.
  618.     */
  619.    ofree = d = strfree;
  620.    if (s) {
  621.       while (slen-- > 0)
  622.          *d++ = *s++;
  623.       }
  624.  
  625.    else
  626.       d += slen;
  627.    strfree = d;
  628.    return ofree;
  629.    }
  630.  
  631. /*
  632.  * alccoexp - allocate a co-expression stack block.
  633.  */
  634.  
  635. struct b_coexpr *alccoexp()
  636.    {
  637.    struct b_coexpr *ep;
  638.    static word coexp_ser = 2;        /* &main is 1 */
  639.  
  640. #ifdef ATTM32
  641.    ep = (struct b_coexpr *)coexp_salloc(); /* 3B2/15/4000 stack */
  642. #else                                   /* ATTM32 */
  643.    ep = (struct b_coexpr *)malloc((msize)stksize);
  644. #endif                                  /* ATTM32 */
  645.  
  646.    /*
  647.     * If malloc failed or if there have been too many co-expression allocations
  648.     * since a collection, attempt to free some co-expression blocks and retry.
  649.     */
  650.  
  651. #ifdef FixedRegions
  652.    if (ep == NULL || alcnum > AlcMax) {
  653. #else                                   /* FixedRegions */
  654.    if (ep == NULL) {
  655. #endif                                  /* Fixed Regions */
  656.  
  657.       collect(Static);
  658.  
  659. #ifdef ATTM32           /* not needed, but here to play it safe */
  660.       ep = (struct b_coexpr *)coexp_salloc(); /* 3B2/15/4000 stack */
  661. #else                                   /* ATTM32 */
  662.       ep = (struct b_coexpr *)malloc((msize)stksize);
  663. #endif                                  /* ATTM32 */
  664.  
  665.       }
  666.  
  667.    if (ep == NULL) {
  668.       k_errornumber = -305;
  669.       k_errortext = "";
  670.       k_errorvalue = nulldesc;
  671.       return NULL;
  672.       }
  673.  
  674. #ifdef FixedRegions
  675.    alcnum++;                    /* increment allocation count since last g.c. */
  676. #endif                                  /* FixedRegions */
  677.  
  678.    ep->title = T_Coexpr;
  679.    ep->es_actstk = NULL;
  680.    ep->size = 0;
  681.    ep->id = coexp_ser++;
  682.    ep->nextstk = stklist;
  683.    stklist = ep;
  684.    MMStat((char *)ep, stksize, 'X');
  685.    return ep;
  686.    }
  687.  
  688. /*
  689.  * alcactiv - allocate a co-expression activation block.
  690.  */
  691.  
  692. struct astkblk *alcactiv()
  693.    {
  694.    struct astkblk *abp;
  695.  
  696.    abp = (struct astkblk *)malloc((msize)sizeof(struct astkblk));
  697.  
  698. #ifdef FixedRegions
  699.    /*
  700.     * If malloc failed, attempt to free some co-expression blocks and retry.
  701.     */
  702.    if (abp == NULL) {
  703.       collect(Static);
  704.       abp = (struct astkblk *)malloc((msize)sizeof(struct astkblk));
  705.       }
  706. #endif                                  /* FixedRegions */
  707.  
  708.    if (abp == NULL) {
  709.       k_errornumber = -305;
  710.       k_errortext = "";
  711.       k_errorvalue = nulldesc;
  712.       return NULL;
  713.       }
  714.    abp->nactivators = 0;
  715.    abp->astk_nxt = NULL;
  716.    return abp;
  717.    }
  718.  
  719. /*
  720.  * alcrefresh - allocate a co-expression refresh block.
  721.  */
  722.  
  723. struct b_refresh *alcrefresh(entryx, na, nl)
  724. word *entryx;
  725. int na, nl;
  726.    {
  727.    int size;
  728.    struct b_refresh *blk;
  729.  
  730.    size = Vsizeof(struct b_refresh) + (na + nl) * sizeof(struct descrip);
  731.    blk = (struct b_refresh *)alcblk((uword)size, T_Refresh);
  732.    blk->blksize = size;
  733.    blk->ep = entryx;
  734.    blk->numlocals = nl;
  735.    return blk;
  736.    }
  737.  
  738. /*
  739.  * blkreq - insure that at least bytes of space are left in the block region.
  740.  *  The amount of space needed is transmitted to the collector via
  741.  *  the global variable blkneed.
  742.  */
  743.  
  744. int blkreq(bytes)
  745. uword bytes;
  746.    {
  747.    blkneed = bytes;
  748.    if (bytes > (uword)DiffPtrs(blkend,blkfree)) {
  749.       coll_blk++;
  750.       collect(Blocks);
  751.       if (bytes > (uword)DiffPtrs(blkend,blkfree))
  752.          RetError(-307, nulldesc);
  753.       }
  754.    return Success;
  755.    }
  756.  
  757. /*
  758.  * strreq - insure that at least n of space are left in the string
  759.  *  space.  The amount of space needed is transmitted to the collector
  760.  *  via the global variable strneed.
  761.  */
  762.  
  763. int strreq(n)
  764. uword n;
  765.    {
  766.    strneed = n;                 /* save in case of collection */
  767.    if (n > (uword)DiffPtrs(strend,strfree)) {
  768.       coll_str++;
  769.       collect(Strings);
  770.       if (n > (uword)DiffPtrs(strend,strfree)) {
  771.  
  772. #ifdef FixedRegions
  773.          if (qualfail)
  774.             RetError(-304, nulldesc);
  775. #endif                                  /* FixedRegions */
  776.  
  777.          RetError(-306, nulldesc);
  778.          }
  779.       }
  780.    return Success;
  781.    }
  782.  
  783. /*
  784.  * cofree - collect co-expression blocks.  This is done after
  785.  *  the marking phase of garbage collection and the stacks that are
  786.  *  reachable have pointers to data blocks, rather than T_Coexpr,
  787.  *  in their type field.
  788.  */
  789.  
  790. novalue cofree()
  791.    {
  792.    register struct b_coexpr **ep, *xep;
  793.    extern word mstksize;        /* main stack size */
  794.    register struct astkblk *abp, *xabp;
  795.  
  796.    /*
  797.     * Reset the type for &main.
  798.     */
  799.    BlkLoc(k_main)->coexpr.title = T_Coexpr;
  800.  
  801.    /*
  802.     * The co-expression blocks are linked together through their
  803.     *  nextstk fields, with stklist pointing to the head of the list.
  804.     *  The list is traversed and each stack that was not marked
  805.     *  is freed.
  806.     */
  807.    ep = &stklist;
  808.    while (*ep != NULL) {
  809.       if (BlkType(*ep) == T_Coexpr) {
  810.          xep = *ep;
  811.          *ep = (*ep)->nextstk;
  812.          /*
  813.           * Free the astkblks.  There should always be one and it seems that
  814.           *  it's not possible to have more than one, but nonetheless, the
  815.           *  code provides for more than one.
  816.           */
  817.          for (abp = xep->es_actstk; abp; ) {
  818.             xabp = abp;
  819.             abp = abp->astk_nxt;
  820.             free((pointer)xabp);
  821.             }
  822.          free((pointer)xep);
  823.          }
  824.       else {
  825.          BlkType(*ep) = T_Coexpr;
  826.          MMStat((char *)(*ep), stksize, 'X');
  827.          ep = &(*ep)->nextstk;
  828.          }
  829.       }
  830.    MMStat((char *)stack, mstksize, 'X');  /* Also record main stack */
  831.    }
  832.  
  833. /*
  834.  * collect - do a garbage collection.
  835.  */
  836.  
  837. novalue collect(region)
  838. int region;
  839.    {
  840.    register dptr dp;
  841.    struct b_coexpr *cp;
  842.  
  843.  
  844.    MMBGC(region);
  845.  
  846. #ifdef EvalTrace
  847.    if (trfile) {
  848.       fprintf(trfile,"c\t%ld\t%ld\t%d\n",colmno,lineno,region);
  849.       }
  850. #endif                    /* EvalTrace */
  851.  
  852.    coll_tot++;
  853.  
  854. #ifdef FixedRegions
  855.    alcnum = 0;
  856. #endif                                  /* FixedRegions */
  857.  
  858.    /*
  859.     * Garbage collection cannot be done until initialization is complete.
  860.     */
  861.    if (sp == NULL)
  862.       return;
  863.  
  864. #if MACINTOSH
  865. #if MPW
  866.    SetCursor(*GetCursor(watchCursor));    /* Set watch cursor */
  867. #endif                    /* MPW */
  868. #endif                    /* MACINTOSH */
  869.  
  870.    /*
  871.     * Sync the values (used by sweep) in the coexpr block for ¤t
  872.     *  with the current values.
  873.     */
  874.    cp = (struct b_coexpr *)BlkLoc(k_current);
  875.    cp->es_pfp = pfp;
  876.    cp->es_gfp = gfp;
  877.    cp->es_efp = efp;
  878.    cp->es_sp = sp;
  879.  
  880.    /*
  881.     * Reset qualifier list.
  882.     */
  883.  
  884. #ifndef FixedRegions
  885.    quallist = (dptr *)blkfree;
  886. #endif                                  /* FixedRegions */
  887.  
  888.    qualfree = quallist;
  889.    qualfail = 0;
  890.  
  891.    /*
  892.     * Mark the stacks for &main and the current co-expression.
  893.     */
  894.    markblock(&k_main);
  895.    markblock(&k_current);
  896.    /*
  897.     * Mark &subject and the cached s2 and s3 strings for map.
  898.     */
  899.    postqual(&k_subject);
  900.    if (Qual(maps2))                     /*  caution:  the cached arguments of */
  901.       postqual(&maps2);                 /*  map may not be strings. */
  902.    else if (Pointer(maps2))
  903.       markblock(&maps2);
  904.    if (Qual(maps3))
  905.       postqual(&maps3);
  906.    else if (Pointer(maps3))
  907.       markblock(&maps3);
  908.  
  909.    /*
  910.     * Mark the tended descriptors and the global and static variables.
  911.     */
  912.    for (dp = &tended[1]; dp <= &tended[ntended]; dp++)
  913.       if (Qual(*dp))
  914.          postqual(dp);
  915.       else if (Pointer(*dp))
  916.          markblock(dp);
  917.    for (dp = globals; dp < eglobals; dp++)
  918.       if (Qual(*dp))
  919.          postqual(dp);
  920.       else if (Pointer(*dp))
  921.          markblock(dp);
  922.    for (dp = statics; dp < estatics; dp++)
  923.       if (Qual(*dp))
  924.          postqual(dp);
  925.       else if (Pointer(*dp))
  926.          markblock(dp);
  927.  
  928.    reclaim(region);
  929.  
  930.  
  931.    MMEGC();
  932.  
  933. #ifndef FixedRegions
  934.    if (qualfail && (region == Strings || statneed) &&
  935.       DiffPtrs((char *)quallist,blkfree) > Sqlinc)
  936.       /*
  937.        * The string region could not be collected, but it looks like it
  938.        *  needs to be. Collecting the block region gave more room for
  939.        *  the qualifier list, so try again.
  940.        */
  941.        collect(region);
  942. #endif                          /* FixedRegions */
  943.  
  944.    }
  945.  
  946. /*
  947.  * markblock - mark each accessible block in the block region and build
  948.  *  back-list of descriptors pointing to that block. (Phase I of garbage
  949.  *  collection.)
  950.  */
  951.  
  952. novalue markblock(dp)
  953. dptr dp;
  954.    {
  955.    register dptr dp1;
  956.    register char *block, *endblock;
  957.    word type, fdesc;
  958.    int numptr;
  959.    register union block **ptr, **lastptr;
  960.  
  961.    /*
  962.     * Get the block to which dp points.
  963.     */
  964.  
  965.    block = (char *)BlkLoc(*dp);
  966.    if (InRange(blkbase,block,blkfree)) {
  967.       if (Var(*dp) && !Tvar(*dp)) {
  968.          /*
  969.           * The descriptor is a variable; block now points to the head of the
  970.           *  block containing the descriptor.
  971.           */
  972.          if (Offset(*dp) == 0)
  973.             return;
  974.          }
  975.  
  976.       type = BlkType(block);
  977.       if ((uword)type <= MaxType) {
  978.  
  979.          /*
  980.           * The type is valid, which indicates that this block has not
  981.           *  been marked.  Point endblock to the byte past the end
  982.           *  of the block.
  983.           */
  984.          endblock = block + BlkSize(block);
  985.          MMMark(block,(int)type);
  986.          }
  987.  
  988.       /*
  989.        * Add dp to the back chain for the block and point the
  990.        *  block (via the type field) to dp.vword.
  991.        */
  992.       BlkLoc(*dp) = (union block *)type;
  993.       BlkType(block) = (uword)&BlkLoc(*dp);
  994.  
  995.       if ((unsigned int)type <= MaxType) {
  996.          /*
  997.           * The block was not marked; process pointers and descriptors
  998.           *  within the block.
  999.           */
  1000.          if ((fdesc = firstp[type]) > 0) {
  1001.             /*
  1002.              * The block contains pointers; mark each pointer.
  1003.              */
  1004.             ptr = (union block **)(block + fdesc);
  1005.             numptr = ptrno[type];
  1006.             if (numptr > 0)
  1007.                lastptr = ptr + numptr;
  1008.             else
  1009.                lastptr = (union block **)endblock;
  1010.             for (; ptr < lastptr; ptr++)
  1011.                if (*ptr != NULL)
  1012.                   markptr(ptr);
  1013.             }
  1014.          if ((fdesc = firstd[type]) > 0)
  1015.             /*
  1016.              * The block contains descriptors; mark each descriptor.
  1017.              */
  1018.             for (dp1 = (dptr)(block + fdesc);
  1019.                  (char *)dp1 < endblock; dp1++) {
  1020.                if (Qual(*dp1))
  1021.                   postqual(dp1);
  1022.                else if (Pointer(*dp1))
  1023.                   markblock(dp1);
  1024.                }
  1025.          }
  1026.       }
  1027.    else if (dp->dword == D_Coexpr && (unsigned int)BlkType(block) <= MaxType) {
  1028.       struct b_coexpr *cp;
  1029.       struct astkblk *abp;
  1030.       int i;
  1031.       struct descrip adesc;
  1032.  
  1033.       /*
  1034.        * dp points to a co-expression block that has not been
  1035.        *  marked.  Point the block to dp.  Sweep the interpreter
  1036.        *  stack in the block.  Then mark the block for the
  1037.        *  activating co-expression and the refresh block.
  1038.        */
  1039.       BlkType(block) = (uword)dp;
  1040.       sweep((struct b_coexpr *)block);
  1041.  
  1042. #ifdef Coexpr
  1043.       /*
  1044.        * Mark the activators of this co-expression.   The activators are
  1045.        *  stored as a list of addresses, but markblock requires the address
  1046.        *  of a descriptor.  To accommodate markblock, the dummy descriptor
  1047.        *  adesc is filled in with each activator address in turn and then
  1048.        *  marked.  Since co-expressions and the descriptors that reference
  1049.        *  them don't participate in the back-chaining scheme, it's ok to
  1050.        *  reuse the descriptor in this manner.
  1051.        */
  1052.       cp = (struct b_coexpr *)block;
  1053.       adesc.dword = D_Coexpr;
  1054.       for (abp = cp->es_actstk; abp != NULL; abp = abp->astk_nxt) {
  1055.          for (i = 1; i <= abp->nactivators; i++) {
  1056.             BlkLoc(adesc) = (union block *)abp->arec[i-1].activator;
  1057.             markblock(&adesc);
  1058.             }
  1059.          }
  1060.       markblock(&((struct b_coexpr *)block)->freshblk);
  1061. #endif                                  /* Coexpr */
  1062.  
  1063.       }
  1064.    }
  1065.  
  1066. /*
  1067.  * markptr - just like mark block except the object pointing at the block
  1068.  *  is just a block pointer, not a descriptor.
  1069.  */
  1070.  
  1071. novalue markptr(ptr)
  1072. union block **ptr;
  1073.    {
  1074.    register dptr dp;
  1075.    register char *block, *endblock;
  1076.    word type, fdesc;
  1077.    int numptr;
  1078.    register union block **ptr1, **lastptr;
  1079.  
  1080.    /*
  1081.     * Get the block to which ptr points.
  1082.     */
  1083.    block = (char *)*ptr;
  1084.    if (InRange(blkbase,block,blkfree)) {
  1085.       type = BlkType(block);
  1086.       if ((uword)type <= MaxType) {
  1087.          /*
  1088.           * The type is valid, which indicates that this block has not
  1089.           *  been marked.  Point endblock to the byte past the end
  1090.           *  of the block.
  1091.           */
  1092.          endblock = block + BlkSize(block);
  1093.          MMMark(block,(int)type);
  1094.          }
  1095.  
  1096.       /*
  1097.        * Add ptr to the back chain for the block and point the
  1098.        *  block (via the type field) to ptr.
  1099.        */
  1100.       *ptr = (union block *)type;
  1101.       BlkType(block) = (uword)ptr;
  1102.  
  1103.       if ((unsigned int)type <= MaxType) {
  1104.          /*
  1105.           * The block was not marked; process pointers and descriptors
  1106.           *  within the block.
  1107.           */
  1108.          if ((fdesc = firstp[type]) > 0) {
  1109.             /*
  1110.              * The block contains pointers; mark each pointer.
  1111.              */
  1112.             ptr1 = (union block **)(block + fdesc);
  1113.             numptr = ptrno[type];
  1114.             if (numptr > 0)
  1115.                lastptr = ptr1 + numptr;
  1116.             else
  1117.                lastptr = (union block **)endblock;
  1118.             for (; ptr1 < lastptr; ptr1++)
  1119.                if (*ptr1 != NULL)
  1120.                   markptr(ptr1);
  1121.             }
  1122.          if ((fdesc = firstd[type]) > 0)
  1123.             /*
  1124.              * The block contains descriptors; mark each descriptor.
  1125.              */
  1126.             for (dp = (dptr)(block + fdesc);
  1127.                  (char *)dp < endblock; dp++) {
  1128.                if (Qual(*dp))
  1129.                   postqual(dp);
  1130.                else if (Pointer(*dp))
  1131.                   markblock(dp);
  1132.                }
  1133.          }
  1134.       }
  1135.    }
  1136.  
  1137. /*
  1138.  * adjust - adjust pointers into the block region, beginning with block oblk
  1139.  *  and basing the "new" block region at nblk.  (Phase II of garbage
  1140.  *  collection.)
  1141.  */
  1142.  
  1143. novalue adjust(source,dest)
  1144. char *source, *dest;
  1145.    {
  1146.    register union block **nxtptr, **tptr;
  1147.  
  1148.    /*
  1149.     * Loop through to the end of allocated block region, moving source
  1150.     *  to each block in turn and using the size of a block to find the
  1151.     *  next block.
  1152.     */
  1153.    while (source < blkfree) {
  1154.       if ((uword)(nxtptr = (union block **)BlkType(source)) > MaxType) {
  1155.  
  1156.          /*
  1157.           * The type field of source is a back pointer.  Traverse the
  1158.           *  chain of back pointers, changing each block location from
  1159.           *  source to dest.
  1160.           */
  1161.          while ((uword)nxtptr > MaxType) {
  1162.             tptr = nxtptr;
  1163.             nxtptr = (union block **) *nxtptr;
  1164.             *tptr = (union block *)dest;
  1165.             }
  1166.          BlkType(source) = (uword)nxtptr | F_Mark;
  1167.          dest += BlkSize(source);
  1168.          }
  1169.       source += BlkSize(source);
  1170.       }
  1171.    }
  1172.  
  1173. /*
  1174.  * compact - compact good blocks in the block region. (Phase III of garbage
  1175.  *  collection.)
  1176.  */
  1177.  
  1178. novalue compact(source)
  1179. char *source;
  1180.    {
  1181.    register char *dest;
  1182.    register word size;
  1183.  
  1184.    /*
  1185.     * Start dest at source.
  1186.     */
  1187.    dest = source;
  1188.  
  1189.    /*
  1190.     * Loop through to end of allocated block space, moving source
  1191.     *  to each block in turn, using the size of a block to find the next
  1192.     *  block.  If a block has been marked, it is copied to the
  1193.     *  location pointed to by dest and dest is pointed past the end
  1194.     *  of the block, which is the location to place the next saved
  1195.     *  block.  Marks are removed from the saved blocks.
  1196.     */
  1197.    while (source < blkfree) {
  1198.       size = BlkSize(source);
  1199.       if (BlkType(source) & F_Mark) {
  1200.          BlkType(source) &= ~F_Mark;
  1201.          if (source != dest)
  1202.             mvc((uword)size,source,dest);
  1203.          dest += size;
  1204.          }
  1205.       source += size;
  1206.       }
  1207.  
  1208.    /*
  1209.     * dest is the location of the next free block.  Now that compaction
  1210.     *  is complete, point blkfree to that location.
  1211.     */
  1212.    blkfree = dest;
  1213.    }
  1214.  
  1215. /*
  1216.  * postqual - mark a string qualifier.  Strings outside the string space
  1217.  *  are ignored.
  1218.  */
  1219.  
  1220. novalue postqual(dp)
  1221. dptr dp;
  1222.    {
  1223.    char *newend;
  1224.  
  1225.    if (InRange(strbase,StrLoc(*dp),strend)) {
  1226.  
  1227.       /*
  1228.        * The string is in the string space.  Add it to the string qualifier
  1229.        *  list, but before adding it, expand the string qualifier list if
  1230.        *  necessary.
  1231.        */
  1232.       if (qualfree >= equallist) {
  1233.  
  1234. #ifdef FixedRegions
  1235.          qualfail = 1;
  1236.          return;
  1237. #else                                   /* FixedRegions */
  1238.  
  1239.          newend = (char *)equallist + Sqlinc;
  1240.          /*
  1241.           * Make sure region has not changed and that it can be expanded.
  1242.           */
  1243.          if (currend != sbrk((word)0) || (int)brk((char *)newend) == -1) {
  1244.             qualfail = 1;
  1245.             return;
  1246.             }
  1247.          equallist = (dptr *)newend;
  1248.          currend = sbrk((word)0);
  1249.  
  1250. #ifdef QuallistExp
  1251.          fprintf(stderr,"size of quallist = %ld\n",
  1252.             (long)DiffPtrs((char *)equallist,(char *)quallist));
  1253.          fflush(stderr);
  1254. #endif                                  /* QuallistExp */
  1255. #endif                                  /* FixedRegions */
  1256.  
  1257.          }
  1258.       *qualfree++ = dp;
  1259.       }
  1260.    }
  1261.  
  1262. /*
  1263.  * scollect - collect the string space.  quallist is a list of pointers to
  1264.  *  descriptors for all the reachable strings in the string space.  For
  1265.  *  ease of description, it is referred to as if it were composed of
  1266.  *  descriptors rather than pointers to them.
  1267.  */
  1268.  
  1269. novalue scollect(extra)
  1270. word extra;
  1271.    {
  1272.    register char *source, *dest;
  1273.    register dptr *qptr;
  1274.    char *cend;
  1275.  
  1276.    if (qualfree <= quallist) {
  1277.       /*
  1278.        * There are no accessible strings.  Thus, there are none to
  1279.        *  collect and the whole string space is free.
  1280.        */
  1281.       strfree = strbase;
  1282.       return;
  1283.       }
  1284.    /*
  1285.     * Sort the pointers on quallist in ascending order of string
  1286.     *  locations.
  1287.     */
  1288.    qsort((char *)quallist, (int)(DiffPtrs((char *)qualfree,(char *)quallist)) /
  1289.      sizeof(dptr *), sizeof(dptr), qlcmp);
  1290.    /*
  1291.     * The string qualifiers are now ordered by starting location.
  1292.     */
  1293.    dest = strbase;
  1294.    source = cend = StrLoc(**quallist);
  1295.  
  1296.    /*
  1297.     * Loop through qualifiers for accessible strings.
  1298.     */
  1299.    for (qptr = quallist; qptr < qualfree; qptr++) {
  1300.       if (StrLoc(**qptr) > cend) {
  1301.  
  1302.          /*
  1303.           * qptr points to a qualifier for a string in the next clump.
  1304.           *  The last clump is moved, and source and cend are set for
  1305.           *  the next clump.
  1306.           */
  1307.          MMSMark(source,DiffPtrs(cend,source));
  1308.          while (source < cend)
  1309.             *dest++ = *source++;
  1310.          source = cend = StrLoc(**qptr);
  1311.          }
  1312.       if ((StrLoc(**qptr) + StrLen(**qptr)) > cend)
  1313.          /*
  1314.           * qptr is a qualifier for a string in this clump; extend
  1315.           *  the clump.
  1316.           */
  1317.          cend = StrLoc(**qptr) + StrLen(**qptr);
  1318.       /*
  1319.        * Relocate the string qualifier.
  1320.        */
  1321.       StrLoc(**qptr) = StrLoc(**qptr) + DiffPtrs(dest,source) + (uword)extra;
  1322.       }
  1323.  
  1324.    /*
  1325.     * Move the last clump.
  1326.     */
  1327.    MMSMark(source,DiffPtrs(cend,source));
  1328.    while (source < cend)
  1329.       *dest++ = *source++;
  1330.    strfree = dest;
  1331.    }
  1332.  
  1333. /*
  1334.  * qlcmp - compare the location fields of two string qualifiers for qsort.
  1335.  */
  1336.  
  1337. int qlcmp(q1,q2)
  1338. dptr *q1, *q2;
  1339.    {
  1340.  
  1341. #if IntBits == 16
  1342.    long l;
  1343.    l = (long)(DiffPtrs(StrLoc(**q1),StrLoc(**q2)));
  1344.    if (l < 0)
  1345.       return -1;
  1346.    else if (l > 0)
  1347.       return 1;
  1348.    else
  1349.       return 0;
  1350. #else                                   /* IntBits = 16 */
  1351.    return (int)(DiffPtrs(StrLoc(**q1),StrLoc(**q2)));
  1352. #endif                                  /* IntBits == 16 */
  1353.  
  1354.    }
  1355.  
  1356. /*
  1357.  * mvc - move n bytes from src to dest
  1358.  *
  1359.  *      The algorithm is to copy the data (using memcopy) in the largest
  1360.  * chunks possible, which is the size of area of the source data not in
  1361.  * the destination area (ie non-overlapped area).  (Chunks are expected to
  1362.  * be fairly large.)
  1363.  */
  1364.  
  1365. novalue mvc(n, src, dest)
  1366. uword n;
  1367. register char *src, *dest;
  1368.    {
  1369.    register char *srcend, *destend;        /* end of data areas */
  1370.    word copy_size;                  /* of size copy_size */
  1371.    word left_over;         /* size of last chunk < copy_size */
  1372.  
  1373.    if (n == 0)
  1374.       return;
  1375.  
  1376.    srcend  = src + n;    /* point at byte after src data */
  1377.    destend = dest + n;   /* point at byte after dest area */
  1378.  
  1379.    if ((destend <= src) || (srcend <= dest))  /* not overlapping */
  1380.       memcopy(dest,src,n);
  1381.  
  1382.    else {                     /* overlapping data areas */
  1383.       if (dest < src) {
  1384.          /*
  1385.           * The move is from higher memory to lower memory.
  1386.           */
  1387.          copy_size = DiffPtrs(src,dest);
  1388.  
  1389.          /* now loop round copying copy_size chunks of data */
  1390.  
  1391.          do {
  1392.             memcopy(dest,src,copy_size);
  1393.             dest = src;
  1394.             src = src + copy_size;
  1395.             }
  1396.          while (DiffPtrs(srcend,src) > copy_size);
  1397.  
  1398.          left_over = DiffPtrs(srcend,src);
  1399.  
  1400.          /* copy final fragment of data - if there is one */
  1401.  
  1402.          if (left_over > 0)
  1403.             memcopy(dest,src,left_over);
  1404.          }
  1405.  
  1406.       else if (dest > src) {
  1407.          /*
  1408.           * The move is from lower memory to higher memory.
  1409.           */
  1410.          copy_size = DiffPtrs(destend,srcend);
  1411.  
  1412.          /* now loop round copying copy_size chunks of data */
  1413.  
  1414.          do {
  1415.             destend = srcend;
  1416.             srcend  = srcend - copy_size;
  1417.             memcopy(destend,srcend,copy_size);
  1418.             }
  1419.          while (DiffPtrs(srcend,src) > copy_size);
  1420.  
  1421.          left_over = DiffPtrs(srcend,src);
  1422.  
  1423.          /* copy intial fragment of data - if there is one */
  1424.  
  1425.          if (left_over > 0) memcopy(dest,src,left_over);
  1426.          }
  1427.  
  1428.       } /* end of overlapping data area code */
  1429.  
  1430.    /*
  1431.     *  Note that src == dest implies no action
  1432.     */
  1433.    }
  1434.  
  1435. /*
  1436.  * sweep - sweep the stack, marking all descriptors there.  Method
  1437.  *  is to start at a known point, specifically, the frame that the
  1438.  *  fp points to, and then trace back along the stack looking for
  1439.  *  descriptors and local variables, marking them when they are found.
  1440.  *  The sp starts at the first frame, and then is moved down through
  1441.  *  the stack.  Procedure, generator, and expression frames are
  1442.  *  recognized when the sp is a certain distance from the fp, gfp,
  1443.  *  and efp respectively.
  1444.  *
  1445.  * Sweeping problems can be manifested in a variety of ways due to
  1446.  *  the "if it can't be identified it's a descriptor" methodology.
  1447.  */
  1448. novalue sweep(ce)
  1449. struct b_coexpr *ce;
  1450.    {
  1451.    register word *s_sp;
  1452.    register struct pf_marker *fp;
  1453.    register struct gf_marker *s_gfp;
  1454.    register struct ef_marker *s_efp;
  1455.    word nargs, type, gsize;
  1456.  
  1457.    fp = ce->es_pfp;
  1458.    s_gfp = ce->es_gfp;
  1459.    if (s_gfp != 0) {
  1460.       type = s_gfp->gf_gentype;
  1461.       if (type == G_Psusp)
  1462.          gsize = Wsizeof(*s_gfp);
  1463.       else
  1464.          gsize = Wsizeof(struct gf_smallmarker);
  1465.       }
  1466.    s_efp = ce->es_efp;
  1467.    s_sp =  ce->es_sp;
  1468.    nargs = 0;                           /* Nargs counter is 0 initially. */
  1469.  
  1470.    while ((fp != 0 || nargs)) {         /* Keep going until current fp is
  1471.                                             0 and no arguments are left. */
  1472.       if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) {
  1473.                                         /* sp has reached the upper
  1474.                                             boundary of a procedure frame,
  1475.                                             process the frame. */
  1476.          s_efp = fp->pf_efp;            /* Get saved efp out of frame */
  1477.          s_gfp = fp->pf_gfp;            /* Get save gfp */
  1478.          if (s_gfp != 0) {
  1479.             type = s_gfp->gf_gentype;
  1480.             if (type == G_Psusp)
  1481.                gsize = Wsizeof(*s_gfp);
  1482.             else
  1483.                gsize = Wsizeof(struct gf_smallmarker);
  1484.             }
  1485.          s_sp = (word *)fp - 1;         /* First argument descriptor is
  1486.                                             first word above proc frame */
  1487.          nargs = fp->pf_nargs;
  1488.          fp = fp->pf_pfp;
  1489.          }
  1490.       else if (s_gfp != NULL && s_sp == (word *)s_gfp + gsize - 1) {
  1491.                                         /* The sp has reached the lower end
  1492.                                             of a generator frame, process
  1493.                                             the frame.*/
  1494.          if (type == G_Psusp)
  1495.             fp = s_gfp->gf_pfp;
  1496.          s_sp = (word *)s_gfp - 1;
  1497.          s_efp = s_gfp->gf_efp;
  1498.          s_gfp = s_gfp->gf_gfp;
  1499.          if (s_gfp != 0) {
  1500.             type = s_gfp->gf_gentype;
  1501.             if (type == G_Psusp)
  1502.                gsize = Wsizeof(*s_gfp);
  1503.             else
  1504.                gsize = Wsizeof(struct gf_smallmarker);
  1505.             }
  1506.          nargs = 1;
  1507.          }
  1508.       else if (s_sp == (word *)s_efp + Wsizeof(*s_efp) - 1) {
  1509.                                             /* The sp has reached the upper
  1510.                                                 end of an expression frame,
  1511.                                                 process the frame. */
  1512.          s_gfp = s_efp->ef_gfp;         /* Restore gfp, */
  1513.          if (s_gfp != 0) {
  1514.             type = s_gfp->gf_gentype;
  1515.             if (type == G_Psusp)
  1516.                gsize = Wsizeof(*s_gfp);
  1517.             else
  1518.                gsize = Wsizeof(struct gf_smallmarker);
  1519.             }
  1520.          s_efp = s_efp->ef_efp;         /*  and efp from frame. */
  1521.          s_sp -= Wsizeof(*s_efp);       /* Move past expression frame marker. */
  1522.          }
  1523.       else {                            /* Assume the sp is pointing at a
  1524.                                             descriptor. */
  1525.          if (Qual(*((dptr)(&s_sp[-1]))))
  1526.             postqual((dptr)&s_sp[-1]);
  1527.          else if (Pointer(*((dptr)(&s_sp[-1]))))
  1528.             markblock((dptr)&s_sp[-1]);
  1529.          s_sp -= 2;                     /* Move past descriptor. */
  1530.          if (nargs)                     /* Decrement argument count if in an*/
  1531.             nargs--;                    /*  argument list. */
  1532.          }
  1533.       }
  1534.    }
  1535.  
  1536. #ifdef DeBugIconx
  1537. /*
  1538.  * descr - dump a descriptor.  Used only for debugging.
  1539.  */
  1540.  
  1541. novalue descr(dp)
  1542. dptr dp;
  1543.    {
  1544.    int i;
  1545.  
  1546.    fprintf(stderr,"%08lx: ",(long)dp);
  1547.    if (Qual(*dp))
  1548.       fprintf(stderr,"%15s","qualifier");
  1549.    else if (Var(*dp) && !Tvar(*dp))
  1550.       fprintf(stderr,"%15s","variable");
  1551.    else {
  1552.       i =  Type(*dp);
  1553.       switch (i) {
  1554.          case T_Null:
  1555.             fprintf(stderr,"%15s","null");
  1556.             break;
  1557.          case T_Integer:
  1558.             fprintf(stderr,"%15s","integer");
  1559.             break;
  1560.          default:
  1561.             fprintf(stderr,"%15s",blkname[i]);
  1562.          }
  1563.       }
  1564.    fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp));
  1565.    }
  1566.  
  1567. /*
  1568.  * blkdump - dump the allocated block region.  Used only for debugging.
  1569.  */
  1570.  
  1571. novalue blkdump()
  1572.    {
  1573.    register char *blk;
  1574.    register word type, size, fdesc;
  1575.    register dptr ndesc;
  1576.  
  1577.    fprintf(stderr,
  1578.       "\nDump of allocated block region.  base:%08lx free:%08lx max:%08lx\n",
  1579.          (long)blkbase,(long)blkfree,(long)blkend);
  1580.    fprintf(stderr,"  loc     type              size  contents\n");
  1581.  
  1582.    for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) {
  1583.       type = BlkType(blk);
  1584.       size = BlkSize(blk);
  1585.       fprintf(stderr," %08lx   %15s   %4ld\n",(long)blk,blkname[type],
  1586.          (long)size);
  1587.       if ((fdesc = firstd[type]) > 0)
  1588.          for (ndesc = (dptr)(blk + fdesc);
  1589.                ndesc < (dptr)(blk + size); ndesc++) {
  1590.             fprintf(stderr,"                                 ");
  1591.             descr(ndesc);
  1592.             }
  1593.       fprintf(stderr,"\n");
  1594.       }
  1595.    fprintf(stderr,"end of block region.\n");
  1596.    }
  1597. #endif                                  /* DeBugIconx */
  1598.